#lang racket

;TAGGED-DATA--------------------------------------------------------------------------------------------------

(define (attach-tag type-tag contents)
  (cons type-tag contents))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Incorrect tagged data: " datum)))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Incorrect tagged data: " datum)))

;OP-ENTRY-----------------------------------------------------------------------------------------------------

(define (equal? x y)
  (cond ((and (not (pair? x)) (not (pair? y))) (eq? x y))
        ((and (pair? x) (pair? y)) (lists-equal? x y))
        (else false)))

(define (lists-equal? x y)
  (cond ((and (null? x) (null? y)) true)
        ((and (not (null? x)) (not (null? y))) (and
                                                (equal? (car x) (car y))
                                                (lists-equal? (cdr x) (cdr y))))
        (else false)))

(define (make-op-entry op type element)
  (list op type element))

(define (this-op? op type entry)
  (and (equal? (car entry) op) (equal? (cadr entry) type)))

(define (get-op-entry entry)
  (caddr entry))

;OP-TABLE-----------------------------------------------------------------------------------------------------

(define op-table '())

(define (put op type element)
  (let ((new-entry (make-op-entry op type element)))
    (set! op-table (cons new-entry op-table)))
  op-table)

(define (get op type)
  (define (get-operation op type operation-table)
    (cond ((null? operation-table) (error "no such operation exists: " op " " type))
          ((this-op? op type (car operation-table)) (get-op-entry (car operation-table)))
          (else (get-operation op type (cdr operation-table)))))
  (get-operation op type op-table))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
           "no method for these types"
           (list op type-tags))))))

;DERIVATION--------------------------------------------------------------------------------------------------

(define (install-sum-package)
  (define (first s) (car s))
  (define (second s) (cadr s))
  (define (make-bin-exp a1 a2) (list a1 a2))
  (define (derive-sum s var)
    (make-sum (deriv (first s) var)
              (deriv (second s) var)))
  
  (define (tag x) (attach-tag '+ x))
  (put 'first '(+) first)
  (put 'second '(+) second)
  (put 'make-bin-exp '+
       (lambda (f s) (tag (make-bin-exp f s))))
  (put 'deriv '+ derive-sum)
  'done)

(define (install-product-package)
  (define (first p) (car p))
  (define (second p) (cadr p))
  (define (make-bin-exp m1 m2) (list m1 m2))
  (define (derive-product p var)
    (make-sum
     (make-product (first p)
                   (deriv (second p) var))
     (make-product (deriv (first p) var)
                   (second p))))
  
  (define (tag x) (attach-tag '* x))
  (put 'first '(*) first)
  (put 'second '(*) second)
  (put 'make-bin-exp '*
       (lambda (f s) (tag (make-bin-exp f s))))
  (put 'deriv '* derive-product)
  'done)

(define (install-exponentiation-package)
  (define (first e) (car e))
  (define (second e) (cadr e))
  (define (make-bin-exp b e) (list b e))
  (define (derive-exponentiation e var)
    (make-product (second e)
                  (make-product (make-exponentiation (first e) (- (second e) 1))
                                (deriv (first e) var))))
  
  (define (tag x) (attach-tag '^ x))
  (put 'first '(^) first)
  (put 'second '(^) second)
  (put 'make-bin-exp '^
       (lambda (f s) (tag (make-bin-exp f s))))
  (put 'deriv '^ derive-exponentiation)
  'done)

(define (first e) (apply-generic 'first e))
(define (second e) (apply-generic 'second e))
(define (make-sum a1 a2)
  ((get 'make-bin-exp '+) a1 a2))
(define (make-product m1 m2)
  ((get 'make-bin-exp '*) m1 m2))
(define (make-exponentiation b e)
  ((get 'make-bin-exp '^) b e))

(define (=number? exp num)
  (and (number? exp) (= exp num)))

(define (variable? x) (symbol? x))

(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp) (if (same-variable? exp var) 1 0))
        (else ((get 'deriv (type-tag exp)) (contents exp)
                                           var))))

;TEST--------------------------------------------------------------------------------------------------------

(install-sum-package)
(install-product-package)
(install-exponentiation-package)

(deriv '(+ (* x (+ 3 y)) (^ x 5)) 'x)